home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / MPW_TOOL / TOOLS / TOOLS_WI / ICON_8 / ICONX_FO / RMISC.C < prev    next >
Text File  |  1990-04-01  |  52KB  |  2,032 lines
  1. /*
  2.  * File: rmisc.c
  3.  *  Contents: deref, eq, [gcvt], getvar, hash, outimage, [qsort],
  4.  *  qtos, trace, pushact, popact, topact, [dumpact], putpos, putsub, putint,
  5.  *  findline, findipc, findfile, [llqsort], doimage, prescan, getimage
  6.  *  printable.
  7.  *
  8.  *  Integer overflow checking.
  9.  */
  10.  
  11. #ifdef IconAlloc
  12. #define free mem_free
  13. #endif                    /* IconAlloc */
  14.  
  15. #include <math.h>
  16. #include "::h:config.h"
  17. #include "::h:rt.h"
  18. #include "rproto.h"
  19. #include <ctype.h>
  20.  
  21. /*
  22.  * Prototypes.
  23.  */
  24.  
  25. hidden novalue    listimage
  26.    Params((FILE *f,struct b_list *lp, int restrict));
  27. hidden novalue    printimage    Params((FILE *f,int c,int q));
  28.  
  29. #ifdef IconQsort
  30. hidden novalue    qswap        Params((char *a, char *b, int w));
  31. #endif                    /* IconQsort */
  32.  
  33. hidden novalue    showlevel    Params((int n));
  34. hidden novalue    showline    Params((char *f,int l));
  35.  
  36. /*
  37.  * deref - dereference a descriptor.
  38.  */
  39.  
  40. int deref(dp)
  41. dptr dp;
  42.    {
  43.    register uword hn;
  44.    register union block *bp;
  45.    struct descrip v, tref;
  46.    union block *tbl;
  47.  
  48.    if (!Tvar(*dp))
  49.        /*
  50.        * An ordinary variable is being dereferenced; just replace
  51.        *  *dp with the descriptor *dp is pointing to.
  52.        */
  53.       *dp = *(dptr)((word *)VarLoc(*dp) + Offset(*dp));
  54.    else switch (Type(*dp)) {
  55.  
  56.          case T_Tvsubs:
  57.             /*
  58.              * A substring trapped variable is being dereferenced.
  59.              *  Point bp to the trapped variable block and v to
  60.              *  the string.
  61.              */
  62.             bp = TvarLoc(*dp);
  63.             v = bp->tvsubs.ssvar;
  64.             if (DeRef(v) == Error)
  65.                return Error;
  66.             if (!Qual(v))
  67.                RetError(103, v);
  68.             if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(v))
  69.                RetError(-205, nulldesc);
  70.             /*
  71.              * Make a descriptor for the substring by getting the
  72.              *  length and pointing into the string.
  73.              */
  74.             StrLen(*dp) = bp->tvsubs.sslen;
  75.             StrLoc(*dp) = StrLoc(v) + bp->tvsubs.sspos - 1;
  76.             break;
  77.  
  78.          case T_Tvtbl:
  79.             if (BlkLoc(*dp)->tvtbl.title == T_Telem) {
  80.                /*
  81.                 * The tvtbl has been converted to a telem and is
  82.                 *  in the table.  Replace the descriptor pointed to
  83.                 *  by dp with the value of the element.
  84.                 */
  85.                 *dp = BlkLoc(*dp)->telem.tval;
  86.                 break;
  87.                 }
  88.  
  89.             /*
  90.              *  Point tbl to the table header block, tref to the
  91.              *  subscripting value, and bp to the appropriate 
  92.              *  chain.  Point dp to a descriptor for the default
  93.              *  value in case the value referenced by the subscript
  94.              *  is not in the table.
  95.              */
  96.             tbl = BlkLoc(*dp)->tvtbl.clink;
  97.             tref = BlkLoc(*dp)->tvtbl.tref;
  98.             hn = BlkLoc(*dp)->tvtbl.hashnum;
  99.             *dp = tbl->table.defvalue;
  100.             bp = *(hchain((union block *)tbl, hn));
  101.  
  102.             /*
  103.              * Traverse the element chain looking for the subscript
  104.              *  value.  If found, replace the descriptor pointed to
  105.              *  by dp with the value of the element.
  106.              */
  107.             while (bp != NULL && bp->telem.hashnum <= hn) {
  108.                if ((bp->telem.hashnum == hn) &&
  109.                   (equiv(&bp->telem.tref, &tref))) {
  110.                      *dp = bp->telem.tval;
  111.                      break;
  112.                      }
  113.                bp = bp->telem.clink;
  114.                }
  115.             break;
  116.  
  117.          case T_Tvkywd:
  118.             bp = TvarLoc(*dp);
  119.             *dp = bp->tvkywd.kyval;
  120.             break;
  121.  
  122.          default:
  123.             syserr("deref: illegal trapped variable");
  124.          }
  125.  
  126. #ifdef DeBugIconx
  127.    if (Var(*dp))
  128.       syserr("deref: didn't get dereferenced");
  129. #endif                    /* DeBugIconx */
  130.  
  131.    return Success;
  132.    }
  133.  
  134. #ifdef IconGcvt
  135. /*
  136.  * gcvt - Convert number to a string in buf.  If possible, ndigit
  137.  *  significant digits are produced, otherwise a form with an exponent is used.
  138.  *
  139.  *  The name is actually #defined as "icon_gcvt" in config.h.
  140.  */
  141. char *gcvt(number, ndigit, buf)
  142. double number;
  143. int ndigit;
  144. char *buf;
  145.    {
  146.    int sign, decpt;
  147.    register char *p1, *p2;
  148.    register i;
  149.  
  150.    p1 = ecvt(number, ndigit, &decpt, &sign);
  151.    p2 = buf;
  152.    if (sign)
  153.       *p2++ = '-';
  154.    for (i=ndigit-1; i>0 && p1[i]=='0'; i--)
  155.       ndigit--;
  156.    if (decpt >= 0 && decpt-ndigit > 4
  157.       || decpt < 0 && decpt < -3) { /* use E-style */
  158.          decpt--;
  159.          *p2++ = *p1++;
  160.          *p2++ = '.';
  161.          for (i=1; i<ndigit; i++)
  162.             *p2++ = *p1++;
  163.          *p2++ = 'e';
  164.          if (decpt<0) {
  165.             decpt = -decpt;
  166.             *p2++ = '-';
  167.             }
  168.          else
  169.             *p2++ = '+';
  170.          if (decpt/100 > 0)
  171.             *p2++ = decpt/100 + '0';
  172.          if (decpt/10 > 0)
  173.             *p2++ = (decpt%100)/10 + '0';
  174.          *p2++ = decpt%10 + '0';
  175.       } else {
  176.          if (decpt<=0) {
  177.          /* if (*p1!='0') */
  178.          *p2++ = '0';
  179.          *p2++ = '.';
  180.          while (decpt<0) {
  181.             decpt++;
  182.             *p2++ = '0';
  183.             }
  184.          }
  185.          for (i=1; i<=ndigit; i++) {
  186.             *p2++ = *p1++;
  187.             if (i==decpt)
  188.                *p2++ = '.';
  189.             }
  190.       if (ndigit<decpt) {
  191.          while (ndigit++<decpt)
  192.             *p2++ = '0';
  193.          *p2++ = '.';
  194.          }
  195.    }
  196.    if (p2[-1]=='.')
  197.       *p2++ = '0';
  198.    *p2 = '\0';
  199.  
  200.    return(buf);
  201.    }
  202. #endif                    /* IconGcvt */
  203.  
  204. /*
  205.  * Get variable descriptor from name.
  206.  */
  207.  
  208. int getvar(s,vp)
  209.    char *s;
  210.    dptr vp;
  211.    {
  212.    register dptr dp;
  213.    register dptr np;
  214.    register int i;
  215.    struct b_proc *bp;
  216.    struct pf_marker *fp = pfp;
  217.  
  218. /*
  219.  * Is it a keyword that's a variable?
  220.  */
  221.    if (*s == '&') {
  222.  
  223.       if (strcmp(s,"&error") == 0) {    /* must put basic one first */
  224.          vp->dword = D_Tvkywd;
  225.          VarLoc(*vp) = (dptr)&tvky_err;
  226.          return Success;
  227.          }
  228.  
  229.  
  230.  
  231.  
  232.       else if (strcmp(s,"&pos") == 0) {
  233.          vp->dword = D_Tvkywd;
  234.          VarLoc(*vp) = (dptr)&tvky_pos;
  235.          return Success;
  236.          }
  237.       else if (strcmp(s,"&random") == 0) {
  238.          vp->dword = D_Tvkywd;
  239.          VarLoc(*vp) = (dptr)&tvky_ran;
  240.          return Success;
  241.          }
  242.       else if (strcmp(s,"&subject") == 0) {
  243.          vp->dword = D_Tvkywd;
  244.          VarLoc(*vp) = (dptr)&tvky_sub;
  245.          return Success;
  246.          }
  247.       else if (strcmp(s,"&trace") == 0) {
  248.          vp->dword = D_Tvkywd;
  249.          VarLoc(*vp) = (dptr)&tvky_trc;
  250.          return Success;
  251.          }
  252.       else return Failure;
  253.       }
  254.  
  255. /*
  256.  * Look for the variable with the name of the local identifiers,
  257.  *  parameters, and static names in each Icon procedure frame on the stack.
  258.  *  If not found among the locals, check the global variables.
  259.  *  If a variable with name is found, variable() returns a variable
  260.  *  descriptor that points to the corresponding value descriptor. 
  261.  *  If no such variable exits, it fails.
  262.  */
  263.       
  264.    /*
  265.     *  If no procedure has been called (as can happen with icon_call(),
  266.     *  dont' try to find local identifier.
  267.     */
  268.    if (pfp == NULL)
  269.       goto glbvars;
  270.    dp = argp;
  271.    bp = (struct b_proc *)BlkLoc(*dp);    /* get address of procedure block */
  272.    
  273.    np = bp->lnames;        /* Check the formal parameter names. */
  274.    for (i = abs((int)bp->nparam); i > 0; i--) {
  275.       dp++;
  276.       if (strcmp(s,StrLoc(*np)) == 0) {
  277.          vp->dword = D_Var;
  278.          VarLoc(*vp) = (dptr)dp;
  279.          return Success;
  280.          }
  281.       np++;
  282.       }
  283.  
  284.    dp = &fp->pf_locals[0];
  285.    for (i = (int)bp->ndynam; i > 0; i--) { /* Check the local dynamic names. */
  286.       if (strcmp(s,StrLoc(*np)) == 0) {
  287.          vp->dword = D_Var;
  288.          VarLoc(*vp) = (dptr)dp;
  289.          return Success;
  290.          }
  291.       np++;
  292.       dp++;
  293.       }
  294.  
  295.    dp = &statics[bp->fstatic]; /* Check the local static names. */
  296.    for (i = (int)bp->nstatic; i > 0; i--) {
  297.       if (strcmp(s,StrLoc(*np)) == 0) {
  298.          vp->dword = D_Var;
  299.          VarLoc(*vp) = (dptr)dp;
  300.          return Success;
  301.          }
  302.       np++;
  303.       dp++;
  304.       }
  305.  
  306. glbvars:
  307.    dp = globals;    /* Check the global variable names. */
  308.    np = gnames;
  309.    while (dp < eglobals) {
  310.       if (strcmp(s,StrLoc(*np)) == 0) {
  311.          vp->dword    =  D_Var;
  312.          VarLoc(*vp) =  (dptr)(dp);
  313.          return Success;
  314.          }
  315.       np++;
  316.       dp++;
  317.       }
  318.    return Failure;
  319. }
  320.  
  321. /*
  322.  * hash - compute hash value of arbitrary object for table and set accessing.
  323.  */
  324.  
  325. uword hash(dp)
  326. dptr dp;
  327.    {
  328.    register char *s;
  329.    register uword i;
  330.    register word j, n;
  331.    register int *bitarr;
  332.    double r;
  333.  
  334.    if (Qual(*dp)) {
  335.  
  336.       /*
  337.        * Compute the hash value for the string based on a scaled sum
  338.        *  of its first ten characters, plus its length.
  339.        */
  340.       i = 0;
  341.       s = StrLoc(*dp);
  342.       j = n = StrLen(*dp);
  343.       if (j > 10)        /* limit scan to first ten characters */
  344.          j = 10;
  345.       while (j-- > 0) {
  346.          i += *s++ & 0xFF;    /* add unsigned version of next char */
  347.          i *= 39;        /* scale total by a nice prime number */
  348.          }
  349.       i += n;            /* add the (untruncated) string length */
  350.       }
  351.  
  352.    else {
  353.  
  354.       switch (Type(*dp)) {
  355.          /*
  356.           * The hash value of an integer is itself times eight times the golden
  357.       *  ratio.  We do this calculation in fixed point.  We don't just use
  358.       *  the integer itself, for that would give bad results with sets
  359.       *  having entries that are multiples of a power of two.
  360.           */
  361.          case T_Integer:
  362.             i = (13255 * (uword)IntVal(*dp)) >> 10;
  363.             break;
  364.  
  365. #ifdef LargeInts
  366.          /*
  367.           * The hash value of a bignum is based on its length and its
  368.           *  most and least significant digits.
  369.           */
  370.      case T_Bignum:
  371.         {
  372.         struct b_bignum *b = &BlkLoc(*dp)->bignumblk;
  373.  
  374.         i = ((b->lsd - b->msd) << 16) ^ 
  375.         (b->digits[b->msd] << 8) ^ b->digits[b->lsd];
  376.         }
  377.         break;
  378. #endif                    /* LargeInts */
  379.  
  380.          /*
  381.           * The hash value of a real number is itself times a constant,
  382.           *  converted to an unsigned integer.  The intent is to scramble
  383.       *  the bits well, in the case of integral values, and to scale up
  384.       *  fractional values so they don't all land in the same bin.
  385.       *  The constant below is 32749 / 29, the quotient of two primes,
  386.       *  and was observed to work well in empirical testing.
  387.           */
  388.          case T_Real:
  389.             GetReal(dp,r);
  390.             i = r * 1129.27586206896558;
  391.             break;
  392.  
  393.          /*
  394.           * The hash value of a cset is based on a convoluted combination
  395.           *  of all its bits.
  396.           */
  397.          case T_Cset:
  398.             i = 0;
  399.             bitarr = BlkLoc(*dp)->cset.bits + CsetSize - 1;
  400.             for (j = 0; j < CsetSize; j++) {
  401.                i += *bitarr--;
  402.                i *= 37;            /* better distribution */
  403.                }
  404.             i %= 1048583;        /* scramble the bits */
  405.             break;
  406.  
  407.          /*
  408.           * The hash value of a list, set, table, or record is its id,
  409.           *   hashed like an integer.
  410.           */
  411.          case T_List:
  412.             i = (13255 * BlkLoc(*dp)->list.id) >> 10;
  413.             break;
  414.  
  415.          case T_Set:
  416.             i = (13255 * BlkLoc(*dp)->set.id) >> 10;
  417.             break;
  418.  
  419.          case T_Table:
  420.             i = (13255 * BlkLoc(*dp)->table.id) >> 10;
  421.             break;
  422.  
  423.          case T_Record:
  424.             i = (13255 * BlkLoc(*dp)->record.id) >> 10;
  425.             break;
  426.  
  427.          default:
  428.             /*
  429.              * For other types, use the type code as the hash
  430.              *  value.
  431.              */
  432.             i = Type(*dp);
  433.             break;
  434.          }
  435.       }
  436.  
  437.    return i;
  438.    }
  439.  
  440. #define StringLimit    16        /* limit on length of imaged string */
  441. #define ListLimit     6        /* limit on list items in image */
  442.  
  443. /*
  444.  * outimage - print image of *dp on file f.  If restrict is nonzero,
  445.  *  fields of records will not be imaged.
  446.  */
  447.  
  448. novalue outimage(f, dp, restrict)
  449. FILE *f;
  450. dptr dp;
  451. int restrict;
  452.    {
  453.    register word i, j;
  454.    register char *s;
  455.    register union block *bp, *vp;
  456.    char *type;
  457.    FILE *fd;
  458.    struct descrip q;
  459.    extern char *blkname[];
  460.    double rresult;
  461.  
  462. outimg:
  463.  
  464.    if (Qual(*dp)) {
  465.       /*
  466.        * *dp is a string qualifier.  Print StringLimit characters of it
  467.        *  using printimage and denote the presence of additional characters
  468.        *  by terminating the string with "...".
  469.        */
  470.       i = StrLen(*dp);
  471.       s = StrLoc(*dp);
  472.       j = Min(i, StringLimit);
  473.       putc('"', f);
  474.       while (j-- > 0)
  475.          printimage(f, *s++, '"');
  476.       if (i > StringLimit)
  477.          fprintf(f, "...");
  478.       putc('"', f);
  479.       return;
  480.       }
  481.  
  482.    if (Var(*dp) && !Tvar(*dp)) {
  483.       /*
  484.        * *d is a variable.  Print "variable =", dereference it, and 
  485.        *  call outimage to handle the value.
  486.        */
  487.       fprintf(f, "(variable = ");
  488.       dp = (dptr)((word *)VarLoc(*dp) + Offset(*dp));
  489.       outimage(f, dp, restrict);
  490.       putc(')', f);
  491.       return;
  492.       }
  493.  
  494.    switch (Type(*dp)) {
  495.  
  496.       case T_Null:
  497.          fprintf(f, "&null");
  498.          return;
  499.  
  500.       case T_Integer:
  501.          fprintf(f, "%ld", (long)IntVal(*dp));
  502.          return;
  503.  
  504. #ifdef LargeInts
  505.       case T_Bignum:
  506.      bigprint(f, dp);
  507.      return;
  508. #endif                    /* LargeInts */
  509.  
  510.       case T_Real:
  511.          {
  512.          char s[30];
  513.          struct descrip rd;
  514.  
  515.          GetReal(dp,rresult);
  516.          rtos(rresult, &rd, s);
  517.          fprintf(f, "%s", StrLoc(rd));
  518.          return;
  519.          }
  520.  
  521.       case T_Cset:
  522.          /*
  523.           * Check for distinguished csets by looking at the address of
  524.           *  of the object to image.  If one is found, print its name.
  525.           */
  526.          if ((char *)BlkLoc(*dp) == (char *)&k_ascii) {
  527.             fprintf(f, "&ascii");
  528.             return;
  529.             }
  530.          else if ((char *)BlkLoc(*dp) == (char *)&k_cset) {
  531.             fprintf(f, "&cset");
  532.             return;
  533.             }
  534.          else if ((char *)BlkLoc(*dp) == (char *)&k_digits) {
  535.             fprintf(f, "&digits");
  536.             return;
  537.             }
  538.          else if ((char *)BlkLoc(*dp) == (char *)&k_lcase) {
  539.             fprintf(f, "&lcase");
  540.             return;
  541.             }
  542.          else if ((char *)BlkLoc(*dp) == (char *)&k_letters) {
  543.             fprintf(f, "&letters");
  544.             return;
  545.             }
  546.          else if ((char *)BlkLoc(*dp) == (char *)&k_ucase) {
  547.             fprintf(f, "&ucase");
  548.             return;
  549.             }
  550.          /*
  551.           * Use printimage to print each character in the cset.  Follow
  552.           *  with "..." if the cset contains more than StringLimit
  553.           *  characters.
  554.           */
  555.          putc('\'', f);
  556.          j = StringLimit;
  557.          for (i = 0; i < 256; i++) {
  558.             if (Testb(i, BlkLoc(*dp)->cset.bits)) {
  559.                if (j-- <= 0) {
  560.                   fprintf(f, "...");
  561.                   break;
  562.                   }
  563.                printimage(f, (int)i, '\'');
  564.                }
  565.             }
  566.          putc('\'', f);
  567.          return;
  568.  
  569.       case T_File:
  570.          /*
  571.           * Check for distinguished files by looking at the address of
  572.           *  of the object to image.  If one is found, print its name.
  573.           */
  574.          if ((fd = BlkLoc(*dp)->file.fd) == stdin)
  575.             fprintf(f, "&input");
  576.          else if (fd == stdout)
  577.             fprintf(f, "&output");
  578.          else if (fd == stderr)
  579.             fprintf(f, "&errout");
  580.          else {
  581.             /*
  582.              * The file isn't a special one, just print "file(name)".
  583.              */
  584.             i = StrLen(BlkLoc(*dp)->file.fname);
  585.             s = StrLoc(BlkLoc(*dp)->file.fname);
  586.             fprintf(f, "file(");
  587.             while (i-- > 0)
  588.                printimage(f, *s++, '\0');
  589.             putc(')', f);
  590.             }
  591.          return;
  592.  
  593.       case T_Proc:
  594.          /*
  595.           * Produce one of:
  596.           *  "procedure name"
  597.           *  "function name"
  598.           *  "record constructor name"
  599.           *
  600.           * Note that the number of dynamic locals is used to determine
  601.           *  what type of "procedure" is at hand.
  602.           */
  603.          i = StrLen(BlkLoc(*dp)->proc.pname);
  604.          s = StrLoc(BlkLoc(*dp)->proc.pname);
  605.          switch ((int)BlkLoc(*dp)->proc.ndynam) {
  606.             default:  type = "procedure"; break;
  607.             case -1:  type = "function"; break;
  608.             case -2:  type = "record constructor"; break;
  609.             }
  610.          fprintf(f, "%s ", type);
  611.          while (i-- > 0)
  612.             printimage(f, *s++, '\0');
  613.          return;
  614.  
  615.       case T_List:
  616.          /*
  617.           * listimage does the work for lists.
  618.           */
  619.          listimage(f, (struct b_list *)BlkLoc(*dp), restrict);
  620.          return;
  621.  
  622.       case T_Table:
  623.          /*
  624.           * Print "table_m(n)" where n is the size of the table.
  625.           */
  626.          fprintf(f, "table_%ld(%ld)", (long)BlkLoc(*dp)->table.id,
  627.             (long)BlkLoc(*dp)->table.size);
  628.          return;
  629.  
  630.       case T_Set:
  631.     /*
  632.          * print "set_m(n)" where n is the cardinality of the set
  633.          */
  634.     fprintf(f,"set_%ld(%ld)",(long)BlkLoc(*dp)->set.id,
  635.            (long)BlkLoc(*dp)->set.size);
  636.     return;
  637.  
  638.       case T_Record:
  639.          /*
  640.           * If restrict is nonzero, print "record(n)" where n is the
  641.           *  number of fields in the record.  If restrict is zero, print
  642.           *  the image of each field instead of the number of fields.
  643.           */
  644.          bp = BlkLoc(*dp);
  645.          i = StrLen(bp->record.recdesc->proc.recname);
  646.          s = StrLoc(bp->record.recdesc->proc.recname);
  647.          fprintf(f, "record ");
  648.          while (i-- > 0)
  649.             printimage(f, *s++, '\0');
  650.         fprintf(f, "_%ld", bp->record.id);
  651.          j = bp->record.recdesc->proc.nfields;
  652.          if (j <= 0)
  653.             fprintf(f, "()");
  654.          else if (restrict > 0)
  655.             fprintf(f, "(%ld)", (long)j);
  656.          else {
  657.             putc('(', f);
  658.             i = 0;
  659.             for (;;) {
  660.                outimage(f, &bp->record.fields[i], restrict+1);
  661.                if (++i >= j)
  662.                   break;
  663.                putc(',', f);
  664.                }
  665.             putc(')', f);
  666.             }
  667.          return;
  668.  
  669.       case T_Tvsubs:
  670.          /*
  671.           * Produce "v[i+:j] = value" where v is the image of the variable
  672.           *  containing the substring, i is starting position of the substring
  673.           *  j is the length, and value is the string v[i+:j].    If the length
  674.           *  (j) is one, just produce "v[i] = value".
  675.           */
  676.          bp = BlkLoc(*dp);
  677.      dp = VarLoc(bp->tvsubs.ssvar);
  678.      if (!Tvar(bp->tvsubs.ssvar))
  679.             dp = (dptr)((word *)dp + Offset(bp->tvsubs.ssvar));
  680.          if (dp == (dptr)&tvky_sub)
  681.             fprintf(f, "&subject");
  682.          else outimage(f, dp, restrict);
  683.          if (bp->tvsubs.sslen == 1)
  684.             fprintf(f, "[%ld]", (long)bp->tvsubs.sspos);
  685.          else
  686.             fprintf(f, "[%ld+:%ld]", (long)bp->tvsubs.sspos,
  687.                     (long)bp->tvsubs.sslen);
  688.          if (dp == (dptr)&tvky_sub) {
  689.             vp = BlkLoc(bp->tvsubs.ssvar);
  690.             if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 >
  691.                   StrLen(vp->tvkywd.kyval))
  692.                return;
  693.             StrLen(q) = bp->tvsubs.sslen;
  694.             StrLoc(q) = StrLoc(vp->tvkywd.kyval) + bp->tvsubs.sspos - 1;
  695.             fprintf(f, " = ");
  696.             dp = &q;
  697.             goto outimg;
  698.             }
  699.          else if (Qual(*dp)) {
  700.             if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(*dp))
  701.                return;
  702.             StrLen(q) = bp->tvsubs.sslen;
  703.             StrLoc(q) = StrLoc(*dp) + bp->tvsubs.sspos - 1;
  704.             fprintf(f, " = ");
  705.             dp = &q;
  706.             goto outimg;
  707.             }
  708.          return;
  709.  
  710.       case T_Tvtbl:
  711.          bp = BlkLoc(*dp);
  712.          /*
  713.           * It is possible that the descriptor that thinks it is pointing
  714.           *  to a tabel-element trapped variable may actually be pointing
  715.           *  at a table element block which had been converted from a
  716.           *  trapped variable. Check for this first and if it is a table
  717.           *  element block, produce the outimage of its value.
  718.           */
  719.          if (bp->tvtbl.title == T_Telem) {
  720.             outimage(f, &bp->tvtbl.tval, restrict);
  721.             return;
  722.             }
  723.          /*
  724.           * It really was a tvtbl - produce "t[s]" where t is the image of
  725.           *  the table containing the element and s is the image of the
  726.           *  subscript.
  727.           */
  728.          else {
  729.         dp->dword = D_Table;
  730.         BlkLoc(*dp) = bp->tvtbl.clink;
  731.             outimage(f, dp, restrict);
  732.             putc('[', f);
  733.             outimage(f, &bp->tvtbl.tref, restrict);
  734.             putc(']', f);
  735.             return;
  736.             }
  737.  
  738.       case T_Tvkywd:
  739.          bp = BlkLoc(*dp);
  740.          i = StrLen(bp->tvkywd.kyname);
  741.          s = StrLoc(bp->tvkywd.kyname);
  742.          while (i-- > 0)
  743.             putc(*s++, f);
  744.          fprintf(f, " = ");
  745.          outimage(f, &bp->tvkywd.kyval, restrict);
  746.          return;
  747.  
  748.       case T_Coexpr:
  749.          fprintf(f, "co-expression_%ld(%ld)",
  750.             (long)((struct b_coexpr *)BlkLoc(*dp))->id,
  751.             (long)((struct b_coexpr *)BlkLoc(*dp))->size);
  752.          return;
  753.  
  754.       case T_External:
  755.          fprintf(f, "external(%d)",((struct b_external *)BlkLoc(*dp))->blksize);
  756.          return;
  757.  
  758.       default:
  759.          if (Type(*dp) <= MaxType)
  760.             fprintf(f, "%s", blkname[Type(*dp)]);
  761.          else
  762.             syserr("outimage: unknown type");
  763.       }
  764.    }
  765.  
  766. /*
  767.  * printimage - print character c on file f using escape conventions
  768.  *  if c is unprintable, '\', or equal to q.
  769.  */
  770.  
  771. static novalue printimage(f, c, q)
  772. FILE *f;
  773. int c, q;
  774.    {
  775.    if (printable(c)) {
  776.       /*
  777.        * c is printable, but special case ", ', and \.
  778.        */
  779.       switch (c) {
  780.          case '"':
  781.             if (c != q) goto def;
  782.             fprintf(f, "\\\"");
  783.             return;
  784.          case '\'':
  785.             if (c != q) goto def;
  786.             fprintf(f, "\\'");
  787.             return;
  788.          case '\\':
  789.             fprintf(f, "\\\\");
  790.             return;
  791.          default:
  792.          def:
  793.             putc(c, f);
  794.             return;
  795.          }
  796.       }
  797.  
  798.    /*
  799.     * c is some sort of unprintable character.    If it one of the common
  800.     *  ones, produce a special representation for it, otherwise, produce
  801.     *  its hex value.
  802.     */
  803.    switch (c) {
  804.       case '\b':            /* backspace */
  805.          fprintf(f, "\\b");
  806.          return;
  807.  
  808. #if !EBCDIC
  809.       case '\177':            /* delete */
  810. #else                    /* !EBCDIC */
  811.       case '\x07':
  812. #endif                    /* !EBCDIC */
  813.  
  814.          fprintf(f, "\\d");
  815.          return;
  816. #if !EBCDIC
  817.       case '\33':            /* escape */
  818. #else                    /* !EBCDIC */
  819.       case '\x27':
  820. #endif                    /* !EBCDIC */
  821.          fprintf(f, "\\e");
  822.          return;
  823.       case '\f':            /* form feed */
  824.          fprintf(f, "\\f");
  825.          return;
  826.       case LineFeed:            /* new line */
  827.          fprintf(f, "\\n");
  828.          return;
  829.  
  830. #if EBCDIC == 1
  831.       case '\x25':                      /* EBCDIC line feed */
  832.          fprintf(f, "\\l");
  833.          return;
  834. #endif                    /* EBCDIC == 1 */
  835.  
  836.       case CarriageReturn:        /* carriage return */
  837.          fprintf(f, "\\r");
  838.          return;
  839.       case '\t':            /* horizontal tab */
  840.          fprintf(f, "\\t");
  841.          return;
  842.       case '\13':            /* vertical tab */
  843.          fprintf(f, "\\v");
  844.          return;
  845.       default:                /* hex escape sequence */
  846.          fprintf(f, "\\x%02x", ToAscii(c & 0xff));
  847.          return;
  848.       }
  849.    }
  850.  
  851. /*
  852.  * listimage - print an image of a list.
  853.  */
  854.  
  855. static novalue listimage(f, lp, restrict)
  856. FILE *f;
  857. struct b_list *lp;
  858. int restrict;
  859.    {
  860.    register word i, j;
  861.    register struct b_lelem *bp;
  862.    word size, count;
  863.  
  864.    bp = (struct b_lelem *) lp->listhead;
  865.    size = lp->size;
  866.  
  867.    if (restrict > 0 && size > 0) {
  868.       /*
  869.        * Just give indication of size if the list isn't empty.
  870.        */
  871.       fprintf(f, "list_%ld(%ld)", (long)lp->id, (long)size);
  872.       return;
  873.       }
  874.  
  875.    /*
  876.     * Print [e1,...,en] on f.  If more than ListLimit elements are in the
  877.     *  list, produce the first ListLimit/2 elements, an ellipsis, and the
  878.     *  last ListLimit elements.
  879.     */
  880.    fprintf(f, "list_%ld = [", (long)lp->id);
  881.    count = 1;
  882.    i = 0;
  883.    if (size > 0) {
  884.       for (;;) {
  885.          if (++i > bp->nused) {
  886.             i = 1;
  887.             bp = (struct b_lelem *) bp->listnext;
  888.             }
  889.          if (count <= ListLimit/2 || count > size - ListLimit/2) {
  890.             j = bp->first + i - 1;
  891.             if (j >= bp->nslots)
  892.                j -= bp->nslots;
  893.             outimage(f, &bp->lslots[j], restrict+1);
  894.             if (count >= size)
  895.                break;
  896.             putc(',', f);
  897.             }
  898.          else if (count == ListLimit/2 + 1)
  899.             fprintf(f, "...,");
  900.          count++;
  901.          }
  902.       }
  903.    putc(']', f);
  904.    }
  905.  
  906. #ifdef IconQsort
  907. /* qsort(base,nel,width,compar) - quicksort routine
  908.  *
  909.  * A Unix-compatible public domain quicksort.
  910.  * Based on Bentley, CACM 28,7 (July, 1985), p. 675.
  911.  */
  912.      
  913. novalue qsort(base, nel, w, compar)
  914. char *base;
  915. int nel, w;
  916. int (*compar)();
  917. {
  918.    int i, lastlow;
  919.     
  920.    if (nel < 2)
  921.       return;
  922.    qswap(base, base + w * (rand() % nel), w);
  923.    lastlow = 0;
  924.    for (i = 1; i < nel; i++)
  925.       if ((*compar) (base + w * i, base) < 0)
  926.          qswap(base + w * i, base + w * (++lastlow), w);
  927.    qswap(base, base + w * lastlow, w);
  928.    qsort(base, lastlow, w, compar);
  929.    qsort(base + w * (lastlow+1), nel-lastlow-1, w, compar);
  930. }
  931.     
  932. static novalue qswap(a, b, w)        /* swap *a and *b of width w for qsort*/
  933. char *a, *b;
  934. int w;
  935. {
  936.    register t;
  937.     
  938.    while (w--)  {
  939.       t = *a;
  940.       *a++ = *b;
  941.       *b++ = t;
  942.    }
  943. }
  944. #endif                    /* IconQsort */
  945.  
  946. /*
  947.  * qtos - convert a qualified string named by *dp to a C-style string.
  948.  *  Put the C-style string in sbuf if it will fit, otherwise put it
  949.  *  in the string region.
  950.  */
  951.  
  952. int qtos(dp, sbuf)
  953. dptr dp;
  954. char *sbuf;
  955.    {
  956.    register word slen;
  957.    register char *c;
  958.  
  959.    c = StrLoc(*dp);
  960.    slen = StrLen(*dp)++;
  961.    if (slen >= MaxCvtLen) {
  962.       if (strreq(slen + 1) == Error) 
  963.          return Error;
  964.       if (c + slen != strfree)
  965.          StrLoc(*dp) = alcstr(c, slen);
  966.       alcstr("",(word)1);
  967.       }
  968.    else {
  969.       StrLoc(*dp) = sbuf;
  970.       for ( ; slen > 0; slen--)
  971.          *sbuf++ = *c++;
  972.       *sbuf = '\0';
  973.       }
  974.    return Success;
  975.    }
  976.  
  977. /*
  978.  * ctrace - procedure named s is being called with nargs arguments, the first
  979.  *  of which is at arg; produce a trace message.
  980.  */
  981. novalue ctrace(dp, nargs, arg)
  982. dptr dp;
  983. int nargs;
  984. dptr arg;
  985.    {
  986.  
  987.    showline(findfile(ipc.opnd), findline(ipc.opnd));
  988.    showlevel(k_level);
  989.    putstr(stderr, dp);
  990.    putc('(', stderr);
  991.    while (nargs--) {
  992.       outimage(stderr, arg++, 0);
  993.       if (nargs)
  994.          putc(',', stderr);
  995.       }
  996.    putc(')', stderr);
  997.    putc('\n', stderr);
  998.    fflush(stderr);
  999.    }
  1000.  
  1001. /*
  1002.  * rtrace - procedure named s is returning *rval; produce a trace message.
  1003.  */
  1004.  
  1005. novalue rtrace(dp, rval)
  1006. dptr dp;
  1007. dptr rval;
  1008.    {
  1009.    inst t_ipc;
  1010.  
  1011.    /*
  1012.     * Compute the ipc of the return instruction.
  1013.     */
  1014.    t_ipc.op = ipc.op - 1;
  1015.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1016.    showlevel(k_level);
  1017.    putstr(stderr, dp);
  1018.    fprintf(stderr, " returned ");
  1019.    outimage(stderr, rval, 0);
  1020.    putc('\n', stderr);
  1021.    fflush(stderr);
  1022.    }
  1023.  
  1024. /*
  1025.  * failtrace - procedure named s is failing; produce a trace message.
  1026.  */
  1027.  
  1028. novalue failtrace(dp)
  1029. dptr dp;
  1030.    {
  1031.    inst t_ipc;
  1032.  
  1033.    /*
  1034.     * Compute the ipc of the fail instruction.
  1035.     */
  1036.    t_ipc.op = ipc.op - 1;
  1037.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1038.    showlevel(k_level);
  1039.    putstr(stderr, dp);
  1040.    fprintf(stderr, " failed");
  1041.    putc('\n', stderr);
  1042.    fflush(stderr);
  1043.    }
  1044.  
  1045. /*
  1046.  * strace - procedure named s is suspending *rval; produce a trace message.
  1047.  */
  1048.  
  1049. novalue strace(dp, rval)
  1050. dptr dp;
  1051. dptr rval;
  1052.    {
  1053.    inst t_ipc;
  1054.  
  1055.    /*
  1056.     * Compute the ipc of the suspend instruction.
  1057.     */
  1058.    t_ipc.op = ipc.op - 1;
  1059.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1060.    showlevel(k_level);
  1061.    putstr(stderr, dp);
  1062.    fprintf(stderr, " suspended ");
  1063.    outimage(stderr, rval, 0);
  1064.    putc('\n', stderr);
  1065.    fflush(stderr);
  1066.    }
  1067.  
  1068. /*
  1069.  * atrace - procedure named s is being resumed; produce a trace message.
  1070.  */
  1071.  
  1072. novalue atrace(dp)
  1073. dptr dp;
  1074.    {
  1075.    inst t_ipc;
  1076.  
  1077.    /*
  1078.     * Compute the ipc of the instruction causing resumption.
  1079.     */
  1080.    t_ipc.op = ipc.op - 1;
  1081.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1082.    showlevel(k_level);
  1083.    putstr(stderr, dp);
  1084.    fprintf(stderr, " resumed");
  1085.    putc('\n', stderr);
  1086.    fflush(stderr);
  1087.    }
  1088.  
  1089. #ifdef Coexpr
  1090. /*
  1091.  * coacttrace -- co-expression is being activated; produce a trace message.
  1092.  */
  1093. novalue coacttrace(ccp, ncp)
  1094. struct b_coexpr *ccp;
  1095. struct b_coexpr *ncp;
  1096.    {
  1097.    struct b_proc *bp;
  1098.    inst t_ipc;
  1099.  
  1100.    bp = (struct b_proc *)BlkLoc(*argp);
  1101.    /*
  1102.     * Compute the ipc of the activation instruction.
  1103.     */
  1104.    t_ipc.op = ipc.op - 1;
  1105.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1106.    showlevel(k_level);
  1107.    putstr(stderr, &(bp->pname));
  1108.    fprintf(stderr,"; co-expression_%ld : ", (long)ccp->id);
  1109.    outimage(stderr, (dptr)(sp - 3), 0);
  1110.    fprintf(stderr," @ co-expression_%ld\n", (long)ncp->id);
  1111.    fflush(stderr);
  1112.    }
  1113.  
  1114. /*
  1115.  * corettrace -- return from co-expression; produce a trace message.
  1116.  */
  1117. novalue corettrace(ccp, ncp)
  1118. struct b_coexpr *ccp;
  1119. struct b_coexpr *ncp;
  1120.    {
  1121.    struct b_proc *bp;
  1122.    inst t_ipc;
  1123.  
  1124.    bp = (struct b_proc *)BlkLoc(*argp);
  1125.    /*
  1126.     * Compute the ipc of the coret instruction.
  1127.     */
  1128.    t_ipc.op = ipc.op - 1;
  1129.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1130.    showlevel(k_level);
  1131.    putstr(stderr, &(bp->pname));
  1132.    fprintf(stderr,"; co-expression_%ld returned ", (long)ccp->id);
  1133.    outimage(stderr, (dptr)(&ncp->es_sp[-3]), 0);
  1134.    fprintf(stderr," to co-expression_%ld\n", (long)ncp->id);
  1135.    fflush(stderr);
  1136.    }
  1137.  
  1138. /*
  1139.  * cofailtrace -- failure return from co-expression; produce a trace message.
  1140.  */
  1141. novalue cofailtrace(ccp, ncp)
  1142. struct b_coexpr *ccp;
  1143. struct b_coexpr *ncp;
  1144.    {
  1145.    struct b_proc *bp;
  1146.    inst t_ipc;
  1147.  
  1148.    bp = (struct b_proc *)BlkLoc(*argp);
  1149.    /*
  1150.     * Compute the ipc of the cofail instruction.
  1151.     */
  1152.    t_ipc.op = ipc.op - 1;
  1153.    showline(findfile(t_ipc.opnd), findline(t_ipc.opnd));
  1154.    showlevel(k_level);
  1155.    putstr(stderr, &(bp->pname));
  1156.    fprintf(stderr,"; co-epression_%ld failed to co-expression_%ld\n",
  1157.       (long)ccp->id, (long)ncp->id);
  1158.    fflush(stderr);
  1159.    }
  1160. #endif                    /* Coexpr */
  1161.  
  1162. /*
  1163.  * showline - print file and line number information.
  1164.  */
  1165. static novalue showline(f, l)
  1166. char *f;
  1167. int l;
  1168.    {
  1169.    int i;
  1170.  
  1171.    i = strlen(f);
  1172.    while (i > 13) {
  1173.       f++;
  1174.       i--;
  1175.       }
  1176.    if (l > 0)
  1177.       fprintf(stderr, "%-13s: %4d  ",f, l);
  1178.    else
  1179.       fprintf(stderr, "             :      ");
  1180.    }
  1181.  
  1182. /*
  1183.  * showlevel - print "| " n times.
  1184.  */
  1185. static novalue showlevel(n)
  1186. register int n;
  1187.    {
  1188.    while (n-- > 0) {
  1189.       putc('|', stderr);
  1190.       putc(' ', stderr);
  1191.       }
  1192.    }
  1193.  
  1194. /*
  1195.  * putpos - assign value to &pos
  1196.  */
  1197.  
  1198. int putpos(dp,bp)
  1199. dptr dp;
  1200. struct b_tvkywd *bp;
  1201.    {
  1202.  
  1203. #if MACINTOSH && MPW
  1204. /* #pragma unused(bp) */
  1205. #endif                    /* MACINTOSH  && MPW */
  1206.  
  1207.    register word l1;
  1208.    switch (cvint(dp)) {
  1209.  
  1210.       case T_Integer:
  1211.          l1 = cvpos(IntVal(*dp), StrLen(k_subject));
  1212.          if (l1 == CvtFail)
  1213.             return Failure;
  1214.          k_pos = l1;
  1215.          return Success;
  1216.  
  1217.       default:
  1218.          RetError(101, *dp);
  1219.       }
  1220.    }
  1221.  
  1222. /*
  1223.  * putsub - assign value to &subject
  1224.  */
  1225.  
  1226. int putsub(dp,bp)
  1227. dptr dp;
  1228. struct b_tvkywd *bp;
  1229.    {
  1230.  
  1231. #if MACINTOSH && MPW
  1232. /* #pragma unused(bp) */
  1233. #endif                    /* MACINTOSH  && MPW */
  1234.  
  1235.    char sbuf[MaxCvtLen];
  1236.  
  1237.    switch (cvstr(dp, sbuf)) {
  1238.  
  1239.       case Cvt:
  1240.          if (strreq(StrLen(*dp)) == Error)
  1241.             return Error;
  1242.          StrLoc(*dp) = alcstr(StrLoc(*dp), StrLen(*dp));
  1243.          /* no break */
  1244.  
  1245.       case NoCvt:
  1246.          k_subject = *dp;
  1247.          k_pos = 1;
  1248.          return Success;
  1249.  
  1250.      default:
  1251.         RetError(103, *dp);
  1252.  
  1253.       }
  1254.    }
  1255.  
  1256. /*
  1257.  * putint - assign integer value to keyword
  1258.  */
  1259.  
  1260. int putint(dp,bp)
  1261. dptr dp;
  1262. struct b_tvkywd *bp;
  1263.    {
  1264.    switch (cvint(dp)) {
  1265.  
  1266.       case T_Integer:
  1267.          IntVal(bp->kyval) = IntVal(*dp);
  1268.          return Success;
  1269.  
  1270.       default:
  1271.          RetError(101, *dp);
  1272.       }
  1273.    }
  1274.  
  1275. #ifdef Coexpr
  1276. /*
  1277.  * pushact - push actvtr on the activator stack of ce
  1278.  */
  1279. int pushact(ce, actvtr)
  1280. struct b_coexpr *ce, *actvtr;
  1281. {
  1282.    struct astkblk *abp = ce->es_actstk, *nabp;
  1283.    struct actrec *arp;
  1284.  
  1285.    /*
  1286.     * If the last activator is the same as this one, just increment
  1287.     *  its count.
  1288.     */
  1289.    if (abp->nactivators > 0) {
  1290.       arp = &abp->arec[abp->nactivators - 1];
  1291.       if (arp->activator == actvtr) {
  1292.          arp->acount++;
  1293.          return Success;
  1294.          }
  1295.       }
  1296.    /*
  1297.     * This activator is different from the last one.  Push this activator
  1298.     *  on the stack, possibly adding another block.
  1299.     */
  1300.    if (abp->nactivators + 1 > ActStkBlkEnts) {
  1301.       nabp = alcactiv();
  1302.       if (nabp == NULL)
  1303.          return Error;
  1304.       nabp->astk_nxt = abp;
  1305.       abp = nabp;
  1306.       }
  1307.    abp->nactivators++;
  1308.    arp = &abp->arec[abp->nactivators - 1];
  1309.    arp->acount = 1;
  1310.    arp->activator = actvtr;
  1311.    ce->es_actstk = abp;
  1312.    return Success;
  1313. }
  1314.  
  1315. /*
  1316.  * popact - pop the most recent activator from the activator stack of ce
  1317.  *  and return it.
  1318.  */
  1319. struct b_coexpr *popact(ce)
  1320. struct b_coexpr *ce;
  1321. {
  1322.    struct astkblk *abp = ce->es_actstk, *oabp;
  1323.    struct actrec *arp;
  1324.    struct b_coexpr *actvtr;
  1325.  
  1326.    /*
  1327.     * If the current stack block is empty, pop it.
  1328.     */
  1329.    if (abp->nactivators == 0) {
  1330.       oabp = abp;
  1331.       abp = abp->astk_nxt;
  1332.       free((pointer)oabp);
  1333.       }
  1334.  
  1335.    if (abp == NULL || abp->nactivators == 0)
  1336.       syserr("empty activator stack\n");
  1337.  
  1338.    /*
  1339.     * Find the activation record for the most recent co-expression.
  1340.     *  Decrement the activation count and if it is zero, pop that
  1341.     *  activation record and decrement the count of activators.
  1342.     */
  1343.    arp = &abp->arec[abp->nactivators - 1];
  1344.    actvtr = arp->activator;
  1345.    if (--arp->acount == 0)
  1346.       abp->nactivators--;
  1347.  
  1348.    ce->es_actstk = abp;
  1349.    return actvtr;
  1350. }
  1351.  
  1352. /*
  1353.  * topact - return the most recent activator of ce.
  1354.  */
  1355. struct b_coexpr *topact(ce)
  1356. struct b_coexpr *ce;
  1357. {
  1358.    struct astkblk *abp = ce->es_actstk;
  1359.    
  1360.    if (abp->nactivators == 0)
  1361.       abp = abp->astk_nxt;
  1362.    return abp->arec[abp->nactivators-1].activator;
  1363. }
  1364.  
  1365. #ifdef DeBugIconx
  1366. /*
  1367.  * dumpact - dump an activator stack
  1368.  */
  1369. novalue dumpact(ce)
  1370. struct b_coexpr *ce;
  1371. {
  1372.    struct astkblk *abp = ce->es_actstk;
  1373.    struct actrec *arp;
  1374.    int i;
  1375.  
  1376.    if (abp)
  1377.       fprintf(stderr, "Ce %ld ", (long)ce->id);
  1378.    while (abp) {
  1379.       fprintf(stderr, "--- Activation stack block (%x) --- nact = %d\n",
  1380.          abp, abp->nactivators);
  1381.       for (i = abp->nactivators; i >= 1; i--) {
  1382.          arp = &abp->arec[i-1];
  1383.          /*for (j = 1; j <= arp->acount; j++)*/
  1384.          fprintf(stderr, "co-expression_%ld(%d)\n", (long)(arp->activator->id),
  1385.             arp->acount);
  1386.          }
  1387.       abp = abp->astk_nxt;
  1388.       }
  1389. }
  1390. #endif                    /* DeBugIconx */
  1391. #endif                    /* Coexpr */
  1392.  
  1393. /*
  1394.  * findline - find the source line number associated with the ipc
  1395.  */
  1396. int findline(ipc)
  1397. word *ipc;
  1398. {
  1399.    uword ipc_offset;
  1400.    uword size;
  1401.    struct ipc_line *base;
  1402.    extern struct ipc_line *ilines, *elines;
  1403.    extern word *records;
  1404.    static two = 2;    /* some compilers generate bad code for division
  1405.                by a constant that is a power of two ... */
  1406.  
  1407.    if (!InRange(code,ipc,records))
  1408.       return 0;
  1409.    ipc_offset = DiffPtrs((char *)ipc,(char *)code);
  1410.    base = ilines;
  1411.    size = DiffPtrs((char *)elines,(char *)ilines) / sizeof(struct ipc_line *);
  1412.    while (size > 1) {
  1413.       if (ipc_offset >= base[size / two].ipc) {
  1414.          base = &base[size / two];
  1415.          size -= size / two;
  1416.          }
  1417.       else
  1418.          size = size / two;
  1419.       }
  1420.    return (int)base->line;
  1421. }
  1422. /*
  1423.  * findipc - find the first ipc associated with a source-code line number.
  1424.  */
  1425. int findipc(line)
  1426. int line;
  1427. {
  1428.    uword size;
  1429.    struct ipc_line *base;
  1430.    extern struct ipc_line *ilines, *elines;
  1431.    static two = 2;    /* some compilers generate bad code for division
  1432.                by a constant that is a power of two ... */
  1433.  
  1434.    base = ilines;
  1435.    size = DiffPtrs((char *)elines,(char *)ilines) / sizeof(struct ipc_line *);
  1436.    while (size > 1) {
  1437.       if (line >= base[size / two].line) {
  1438.          base = &base[size / two];
  1439.          size -= size / two;
  1440.          }
  1441.       else
  1442.          size = size / two;
  1443.       }
  1444.    return base->ipc;
  1445. }
  1446.  
  1447. /*
  1448.  * findfile - find source file name associated with the ipc
  1449.  */
  1450. char *findfile(ipc)
  1451. word *ipc;
  1452. {
  1453.    uword ipc_offset;
  1454.    struct ipc_fname *p;
  1455.    extern struct ipc_fname *filenms, *efilenms;
  1456.    extern word *records;
  1457.    extern char *strcons;
  1458.  
  1459.    if (!InRange(code,ipc,records))
  1460.       return "?";
  1461.    ipc_offset = DiffPtrs((char *)ipc,(char *)code);
  1462.    for (p = efilenms - 1; p >= filenms; p--)
  1463.       if (ipc_offset >= p->ipc)
  1464.          return strcons + p->fname;
  1465.    fprintf(stderr,"bad ipc/file name table");
  1466.    fflush(stderr);
  1467.    c_exit(ErrorExit);
  1468. }
  1469.  
  1470. #if IntBits == 16
  1471. /* Shell sort with some enhancements from Knuth.. */
  1472.  
  1473. novalue llqsort(base, nel, width, cmp )
  1474. char *base;
  1475. int nel;
  1476. int width;
  1477. int (*cmp)();
  1478. {
  1479.    register long i, j;
  1480.    long int gap;
  1481.    int k;
  1482.    char *p1, *p2, tmp;
  1483.  
  1484.    for( gap=1; gap <= nel; gap = 3*gap + 1 ) ;
  1485.  
  1486.    for( gap /= 3;  gap > 0  ; gap /= 3 )
  1487.        for( i = gap; i < nel; i++ )
  1488.        for( j = i-gap; j >= 0 ; j -= gap ) {
  1489.         p1 = base + ( j     * width);
  1490.         p2 = base + ((j+gap) * width);
  1491.  
  1492.         if( (*cmp)( p1, p2 ) <= 0 ) break;
  1493.  
  1494.         for( k = width; --k >= 0 ;) {
  1495.            tmp     = *p1;
  1496.            *p1++ = *p2;
  1497.            *p2++ = tmp;
  1498.         }
  1499.        }
  1500. }
  1501.  
  1502. #endif                    /* IntBits == 16 */
  1503. /*
  1504.  * doimage(c,q) - allocate character c in string space, with escape
  1505.  *  conventions if c is unprintable, '\', or equal to q.
  1506.  *  Returns number of characters allocated.
  1507.  */
  1508.  
  1509. doimage(c, q)
  1510. int c, q;
  1511.    {
  1512.    static char cbuf[5];
  1513.  
  1514.    if (printable(c)) {
  1515.  
  1516.       /*
  1517.        * c is printable, but special case ", ', and \.
  1518.        */
  1519.       switch (c) {
  1520.          case '"':
  1521.             if (c != q) goto def;
  1522.             alcstr("\\\"", (word)(2));
  1523.             return 2;
  1524.          case '\'':
  1525.             if (c != q) goto def;
  1526.             alcstr("\\'", (word)(2));
  1527.             return 2;
  1528.          case '\\':
  1529.             alcstr("\\\\", (word)(2));
  1530.             return 2;
  1531.          default:
  1532.          def:
  1533.             cbuf[0] = c;
  1534.             alcstr(cbuf, (word)(1));
  1535.             return 1;
  1536.          }
  1537.       }
  1538.  
  1539.    /*
  1540.     * c is some sort of unprintable character.    If it is one of the common
  1541.     *  ones, produce a special representation for it, otherwise, produce
  1542.     *  its hex value.
  1543.     */
  1544.    switch (c) {
  1545.       case '\b':            /*       backspace    */
  1546.          alcstr("\\b", (word)(2));
  1547.          return 2;
  1548.  
  1549. #if !EBCDIC
  1550.       case '\177':            /*      delete      */
  1551. #else                    /* !EBCDIC */
  1552.       case '\x07':            /*      delete    */
  1553. #endif                    /* !EBCDIC */
  1554.  
  1555.          alcstr("\\d", (word)(2));
  1556.          return 2;
  1557.  
  1558. #if !EBCDIC
  1559.       case '\33':            /*        escape     */
  1560. #else                    /* !EBCDIC */
  1561.       case '\x27':            /*          escape       */
  1562. #endif                    /* !EBCDIC */
  1563.  
  1564.          alcstr("\\e", (word)(2));
  1565.          return 2;
  1566.       case '\f':            /*       form feed    */
  1567.          alcstr("\\f", (word)(2));
  1568.          return 2;
  1569.       case LineFeed:            /*       new line    */
  1570.          alcstr("\\n", (word)(2));
  1571.          return 2;
  1572.       case CarriageReturn:        /*       return    */
  1573.          alcstr("\\r", (word)(2));
  1574.          return 2;
  1575.       case '\t':            /*       horizontal tab     */
  1576.          alcstr("\\t", (word)(2));
  1577.          return 2;
  1578.       case '\13':            /*        vertical tab     */
  1579.          alcstr("\\v", (word)(2));
  1580.          return 2;
  1581.       default:                /*      hex escape sequence  */
  1582.          sprintf(cbuf, "\\x%02x", c & 0xff);
  1583.          alcstr(cbuf, (word)(4));
  1584.          return 4;
  1585.       }
  1586.    }
  1587.  
  1588. /*
  1589.  * prescan(d) - return upper bound on length of expanded string.  Note
  1590.  *  that the only time that prescan is wrong is when the string contains
  1591.  *  one of the "special" unprintable characters, e.g. tab.
  1592.  */
  1593. word prescan(d)
  1594. dptr d;
  1595.    {
  1596.    register word slen, len;
  1597.    register char *s, c;
  1598.  
  1599.    s = StrLoc(*d);
  1600.    len = 0;
  1601.    for (slen = StrLen(*d); slen > 0; slen--)
  1602.  
  1603. #if EBCDIC
  1604. #if SASC
  1605.       if (!isascii(c = (*s++)) || iscntrl(c))
  1606. #else                    /* SASC */
  1607.       if (!isprint(c = (*s++)))
  1608. #endif                    /* SASC */
  1609. #else                    /* EBCDIC */
  1610.       if ((c = (*s++)) < ' ' || c >= 0177)
  1611. #endif                    /* EBCDIC */
  1612.  
  1613.          len += 4;
  1614.       else if (c == '"' || c == '\\' || c == '\'')
  1615.          len += 2;
  1616.       else
  1617.          len++;
  1618.  
  1619.    return len;
  1620.    }
  1621.  
  1622. /*
  1623.  * getimage(dp1,dp2) - return string image of object dp1 in dp2.
  1624.  */
  1625.  
  1626. int getimage(dp1,dp2)
  1627.    dptr dp1, dp2;
  1628.    {
  1629.    register word len, outlen, rnlen;
  1630.    register char *s;
  1631.    register union block *bp;
  1632.    char *type;
  1633.    char sbuf[MaxCvtLen];
  1634.    FILE *fd;
  1635.  
  1636.    if (Qual(*dp1)) {
  1637.       /*
  1638.        * Get some string space.  The magic 2 is for the double quote at each
  1639.        *  end of the resulting string.
  1640.        */
  1641.       if (strreq(prescan(dp1) + 2) == Error) 
  1642.          return Error;
  1643.       len = StrLen(*dp1);
  1644.       s = StrLoc(*dp1);
  1645.       outlen = 2;
  1646.  
  1647.       /*
  1648.        * Form the image by putting a quote in the string space, calling
  1649.        *  doimage with each character in the string, and then putting
  1650.        *  a quote at then end.    Note that doimage directly writes into the
  1651.        *  string space.  (Hence the indentation.)  This techinique is used
  1652.        *  several times in this routine.
  1653.        */
  1654.       StrLoc(*dp2) = alcstr("\"", (word)(1));
  1655.       while (len-- > 0)
  1656.          outlen += doimage(*s++, '"');
  1657.       alcstr("\"", (word)(1));
  1658.       StrLen(*dp2) = outlen;
  1659.       return Success;
  1660.       }
  1661.  
  1662.    switch (Type(*dp1)) {
  1663.  
  1664.       case T_Null:
  1665.          StrLoc(*dp2) = "&null";
  1666.          StrLen(*dp2) = 5;
  1667.          return Success;
  1668.  
  1669. #ifdef LargeInts
  1670.       case T_Bignum:
  1671.  
  1672.          {
  1673.          word slen;
  1674.          word dlen;
  1675.  
  1676.          slen = (BlkLoc(*dp1)->bignumblk.lsd - BlkLoc(*dp1)->bignumblk.msd + 1);
  1677.          dlen = slen * NB * 0.3010299956639812;    /* 1 / log2(10) */
  1678.          if (dlen > MaxDigits) {
  1679.             sprintf(sbuf,"integer(~%ld)",dlen - 2); /* center estimage */
  1680.             len = strlen(sbuf);
  1681.             if (strreq(len) == Error)
  1682.                return Error;
  1683.             StrLoc(*dp2) = alcstr(sbuf,strlen(sbuf));
  1684.             StrLen(*dp2) = len;
  1685.             return Success;
  1686.             }
  1687.          }
  1688. #endif                    /* LargeInts */
  1689.  
  1690.       case T_Integer:
  1691.  
  1692.       case T_Real:
  1693.          /*
  1694.           * Form a string representing the number and allocate it.
  1695.           */
  1696.          *dp2 = *dp1;            /* don't clobber dp1 */
  1697.          cvstr(dp2, sbuf);
  1698.          len = StrLen(*dp2);
  1699.          if (strreq(len) == Error) 
  1700.             return Error;
  1701.          StrLoc(*dp2) = alcstr(StrLoc(*dp2), len);
  1702.          StrLen(*dp2) = len;
  1703.          return Success;
  1704.  
  1705.       case T_Cset:
  1706.  
  1707.          /*
  1708.           * Check for distinguished csets by looking at the address of
  1709.           *  of the object to image.  If one is found, make a string
  1710.           *  naming it and return.
  1711.           */
  1712.          if (BlkLoc(*dp1) == ((union block *)&k_ascii)) {
  1713.             StrLoc(*dp2) = "&ascii";
  1714.             StrLen(*dp2) = 6;
  1715.             return Success;
  1716.             }
  1717.          else if (BlkLoc(*dp1) == ((union block *)&k_cset)) {
  1718.             StrLoc(*dp2) = "&cset";
  1719.             StrLen(*dp2) = 5;
  1720.             return Success;
  1721.             }
  1722.          else if (BlkLoc(*dp1) == ((union block *)&k_digits)) {
  1723.             StrLoc(*dp2) = "&digits";
  1724.             StrLen(*dp2) = 7;
  1725.             return Success;
  1726.             }
  1727.          else if (BlkLoc(*dp1) == ((union block *)&k_lcase)) {
  1728.             StrLoc(*dp2) = "&lcase";
  1729.             StrLen(*dp2) = 6;
  1730.             return Success;
  1731.             }
  1732.          else if (BlkLoc(*dp1) == ((union block *)&k_letters)) {
  1733.             StrLoc(*dp2) = "&letters";
  1734.             StrLen(*dp2) = 8;
  1735.             return Success;
  1736.             }
  1737.          else if (BlkLoc(*dp1) == ((union block *)&k_ucase)) {
  1738.             StrLoc(*dp2) = "&ucase";
  1739.             StrLen(*dp2) = 6;
  1740.             return Success;
  1741.             }
  1742.          /*
  1743.           * Convert the cset to a string and proceed as is done for
  1744.           *  string images but use a ' rather than " to bound the
  1745.           *  result string.
  1746.           */
  1747.          cvstr(dp1, sbuf);
  1748.          if (strreq(prescan(dp1) + 2) == Error) 
  1749.             return Error;
  1750.          len = StrLen(*dp1);
  1751.          s = StrLoc(*dp1);
  1752.          outlen = 2;
  1753.          StrLoc(*dp2) = alcstr("'", (word)(1));
  1754.          while (len-- > 0)
  1755.             outlen += doimage(*s++, '\'');
  1756.          alcstr("'", (word)(1));
  1757.          StrLen(*dp2) = outlen;
  1758.          return Success;
  1759.  
  1760.       case T_File:
  1761.          /*
  1762.           * Check for distinguished files by looking at the address of
  1763.           *  of the object to image.  If one is found, make a string
  1764.           *  naming it and return.
  1765.           */
  1766.          if ((fd = BlkLoc(*dp1)->file.fd) == stdin) {
  1767.             StrLen(*dp2) = 6;
  1768.             StrLoc(*dp2) = "&input";
  1769.             }
  1770.          else if (fd == stdout) {
  1771.             StrLen(*dp2) = 7;
  1772.             StrLoc(*dp2) = "&output";
  1773.             }
  1774.          else if (fd == stderr) {
  1775.             StrLen(*dp2) = 7;
  1776.             StrLoc(*dp2) = "&errout";
  1777.             }
  1778.          else {
  1779.             /*
  1780.              * The file is not a standard one; form a string of the form
  1781.              *    file(nm) where nm is the argument originally given to
  1782.              *    open.
  1783.              */
  1784.             if (strreq(prescan(&BlkLoc(*dp1)->file.fname)+6) == Error) 
  1785.                return Error;
  1786.             len = StrLen(BlkLoc(*dp1)->file.fname);
  1787.             s = StrLoc(BlkLoc(*dp1)->file.fname);
  1788.             outlen = 6;
  1789.             StrLoc(*dp2) = alcstr("file(", (word)(5));
  1790.             while (len-- > 0)
  1791.                outlen += doimage(*s++, '\0');
  1792.             alcstr(")", (word)(1));
  1793.             StrLen(*dp2) = outlen;
  1794.             }
  1795.          return Success;
  1796.  
  1797.       case T_Proc:
  1798.          /*
  1799.           * Produce one of:
  1800.           *  "procedure name"
  1801.           *  "function name"
  1802.           *  "record constructor name"
  1803.           *
  1804.           * Note that the number of dynamic locals is used to determine
  1805.           *  what type of "procedure" is at hand.
  1806.           */
  1807.          len = StrLen(BlkLoc(*dp1)->proc.pname);
  1808.          s = StrLoc(BlkLoc(*dp1)->proc.pname);
  1809.          switch ((int)BlkLoc(*dp1)->proc.ndynam) {
  1810.             default:  type = "procedure "; break;
  1811.             case -1:  type = "function "; break;
  1812.             case -2:  type = "record constructor "; break;
  1813.             }
  1814.          outlen = strlen(type);
  1815.          if (strreq(len + outlen) == Error) 
  1816.             return Error;
  1817.          StrLoc(*dp2) = alcstr(type, outlen);
  1818.          alcstr(s, len);
  1819.          StrLen(*dp2) = len + outlen;
  1820.          return Success;
  1821.  
  1822.       case T_List:
  1823.          /*
  1824.           * Produce:
  1825.           *  "list_m(n)"
  1826.           * where n is the current size of the list.
  1827.           */
  1828.          bp = BlkLoc(*dp1);
  1829.          sprintf(sbuf, "list_%ld(%ld)", (long)bp->list.id, (long)bp->list.size);
  1830.          len = strlen(sbuf);
  1831.          if (strreq(len) == Error) 
  1832.             return Error;
  1833.          StrLoc(*dp2) = alcstr(sbuf, len);
  1834.          StrLen(*dp2) = len;
  1835.          return Success;
  1836.  
  1837.       case T_Table:
  1838.          /*
  1839.           * Produce:
  1840.           *  "table_m(n)"
  1841.           * where n is the size of the table.
  1842.           */
  1843.          bp = BlkLoc(*dp1);
  1844.          sprintf(sbuf, "table_%ld(%ld)", (long)bp->table.id,
  1845.             (long)bp->table.size);
  1846.          len = strlen(sbuf);
  1847.          if (strreq(len) == Error) 
  1848.             return Error;
  1849.          StrLoc(*dp2) = alcstr(sbuf, len);
  1850.          StrLen(*dp2) = len;
  1851.          return Success;
  1852.  
  1853.       case T_Set:
  1854.          /*
  1855.           * Produce "set_m(n)" where n is size of the set.
  1856.           */
  1857.          bp = BlkLoc(*dp1);
  1858.          sprintf(sbuf, "set_%ld(%ld)", (long)bp->set.id, (long)bp->set.size);
  1859.          len = strlen(sbuf);
  1860.          if (strreq(len) == Error) 
  1861.             return Error;
  1862.          StrLoc(*dp2) = alcstr(sbuf,len);
  1863.          StrLen(*dp2) = len;
  1864.          return Success;
  1865.  
  1866.       case T_Record:
  1867.          /*
  1868.           * Produce:
  1869.           *  "record name_m(n)"    -- under construction
  1870.           * where n is the number of fields.
  1871.           */
  1872.          bp = BlkLoc(*dp1);
  1873.          rnlen = StrLen(bp->record.recdesc->proc.recname);
  1874.          if (strreq(15 + rnlen) == Error)    /* 15 = *"record " + *"(nnnnnn)"*/
  1875.             return Error;
  1876.          bp = BlkLoc(*dp1);
  1877.          sprintf(sbuf, "_%ld(%ld)", (long)bp->record.id,
  1878.             (long)bp->record.recdesc->proc.nfields);
  1879.          len = strlen(sbuf);
  1880.          StrLoc(*dp2) = alcstr("record ", (word)(7));
  1881.             alcstr(StrLoc(bp->record.recdesc->proc.recname),rnlen);
  1882.             alcstr(sbuf, len);
  1883.          StrLen(*dp2) = 7 + len + rnlen;
  1884.          return Success;
  1885.  
  1886.       case T_Coexpr:
  1887.          /*
  1888.           * Produce:
  1889.           *  "co-expression_m(n)"
  1890.           *  where m is the number of the co-expressions and n is the
  1891.           *  number of results that have been produced.
  1892.           */
  1893.  
  1894.          if (strreq((uword)30) == Error) 
  1895.             return Error;
  1896.          sprintf(sbuf, "_%ld(%ld)", (long)BlkLoc(*dp1)->coexpr.id,
  1897.             (long)BlkLoc(*dp1)->coexpr.size);
  1898.          len = strlen(sbuf);
  1899.          StrLoc(*dp2) = alcstr("co-expression", (word)(13));
  1900.          alcstr(sbuf, len);
  1901.          StrLen(*dp2) = 13 + len;
  1902.          return Success;
  1903.  
  1904.       case T_External:
  1905.          /*
  1906.           * For now, just produce "external(n)". 
  1907.           */
  1908.          sprintf(sbuf, "external(%ld)", (long)BlkLoc(*dp1)->externl.blksize);
  1909.          len = strlen(sbuf);
  1910.          if (strreq(len) == Error) 
  1911.             return Error;
  1912.          StrLoc(*dp2) = alcstr(sbuf, len);
  1913.          StrLen(*dp2) = len;
  1914.          return Success;
  1915.  
  1916.       default:
  1917.          RetError(123,*dp1);
  1918.       }
  1919.    }
  1920.  
  1921. /*
  1922.  * printable(c) -- is c a "printable" character?
  1923.  */
  1924.  
  1925. int printable(c)
  1926. int c;
  1927.    {
  1928.  
  1929. /*
  1930.  * The following code is operating-system dependent [@rmisc.01].
  1931.  *  Determine if a character is "printable".
  1932.  */
  1933.  
  1934. #if PORT
  1935.    return isprint(c);
  1936. Deliberate Syntax Error
  1937. #endif                    /* PORT */
  1938.  
  1939. #if MVS || VM
  1940. #if SASC
  1941.    return isascii(c) && !iscntrl(c);
  1942. #else                    /* SASC */
  1943.    return isprint(c);
  1944. #endif                    /* SASC */
  1945. #endif                                  /* MVS || VM */
  1946.  
  1947. #if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MSDOS || OS2 || UNIX || VMS
  1948.    return (isascii(c) && isprint(c));
  1949. #endif                    /* AMIGA || ATARI_ST ... */
  1950.  
  1951. /*
  1952.  * End of operating-system specific code.
  1953.  */
  1954.    }
  1955.  
  1956. #ifndef AsmOver
  1957. /*
  1958.  * add, sub, mul, neg with overflow check
  1959.  * all return 1 if ok, 0 if would overflow
  1960.  */
  1961.  
  1962. /*
  1963.  *  Note: on some systems an improvement in performance can be obtained by
  1964.  *  replacing the C functions that follow by checks written in assembly
  1965.  *  language.  To do so, add #define AsmOver to ../h/define.h.  If your
  1966.  *  C compiler supports the asm directive, but the new code at the end
  1967.  *  of this section under control of #else.  Otherwise put it a separate
  1968.  *  file.
  1969.  */
  1970.  
  1971. extern int over_flow;
  1972.  
  1973. word add(a, b)
  1974. word a, b;
  1975. {
  1976.    if ((a ^ b) >= 0 && (a >= 0 ? b > MaxLong - a : b < MinLong - a)) {
  1977.       over_flow = 1;
  1978.       return 0;
  1979.       }
  1980.    else {
  1981.      over_flow = 0;
  1982.      return a + b;
  1983.      }
  1984. }
  1985.  
  1986. word sub(a, b)
  1987. word a, b;
  1988. {
  1989.    if ((a ^ b) < 0 && (a >= 0 ? b < a - MaxLong : b > a - MinLong)) {
  1990.       over_flow = 1;
  1991.       return 0;
  1992.       }
  1993.    else {
  1994.       over_flow = 0;
  1995.       return a - b;
  1996.       }
  1997. }
  1998.  
  1999. word mul(a, b)
  2000. word a, b;
  2001. {
  2002.    if (b != 0) {
  2003.       if ((a ^ b) >= 0) {
  2004.      if (a >= 0 ? a > MaxLong / b : a < MaxLong / b) {
  2005.             over_flow = 1;
  2006.         return 0;
  2007.             }
  2008.      }
  2009.       else if (b != -1 && (a >= 0 ? a > MinLong / b : a < MinLong / b)) {
  2010.          over_flow = 1;
  2011.      return 0;
  2012.          }
  2013.       }
  2014.  
  2015.    over_flow = 0;
  2016.    return a * b;
  2017. }
  2018.  
  2019. /* MinLong / -1 overflows; need div3 too */
  2020.  
  2021. word neg(a)
  2022. word a;
  2023. {
  2024.    if (a == MinLong) {
  2025.       over_flow = 1;
  2026.       return 0;
  2027.       }
  2028.    over_flow = 0;
  2029.    return -a;
  2030. }
  2031. #endif                    /* AsmOver */
  2032.